home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / scm / jackal1a.lha / jacal / grammar.scm < prev    next >
Encoding:
Text File  |  1992-12-24  |  3.7 KB  |  128 lines
  1. ;;; JACAL: Symbolic Mathematics System.        -*-scheme-*-
  2. ;;; Copyright 1992 Aubrey Jaffer.
  3. ;;; See the file "COPYING" for terms applying to this program.
  4.  
  5. ;(require 'record)
  6. ;(define grammar-rtd
  7. ;  (make-record-type "grammar"
  8. ;            '(name reader lex-tab read-tab writer write-tab)))
  9. ;(define make-grammar (record-constructor grammar-rtd))
  10. ;(define grammar-name (record-accessor grammar-rtd 'name))
  11. ;(define grammar-reader (record-accessor grammar-rtd 'reader))
  12. ;(define grammar-lex-tab (record-accessor grammar-rtd 'lex-tab))
  13. ;(define grammar-read-tab (record-accessor grammar-rtd 'read-tab))
  14. ;(define grammar-writer (record-accessor grammar-rtd 'writer))
  15. ;(define grammar-write-tab (record-accessor grammar-rtd 'write-tab))
  16.  
  17. (define (make-grammar name reader lex-tab read-tab writer write-tab)
  18.   (cons (cons name reader)
  19.     (cons (cons lex-tab read-tab) (cons writer write-tab))))
  20. (define grammar-name caar)
  21. (define grammar-reader cdar)
  22. (define grammar-lex-tab caadr)
  23. (define grammar-read-tab cdadr)
  24. (define grammar-writer caddr)
  25. (define grammar-write-tab cdddr)
  26.  
  27. (require 'alist)
  28. (define *grammars* '())
  29. (define grammar-associator (alist-associator eq?))
  30. (define (defgrammar name grm)
  31.   (set! *grammars* (grammar-associator *grammars* name grm)))
  32. (define grammar-remover (alist-remover eq?))
  33. (define (rem-grammar name grm)
  34.   (set! *grammars* (grammar-remover *grammars* name grm)))
  35. (define grammar-inquirer (alist-inquirer eq?))
  36. (define (get-grammar name) (grammar-inquirer *grammars* name))
  37.  
  38. (defgrammar 'scheme
  39.   (make-grammar 'scheme
  40.         (lambda (grm) (read))
  41.         #f
  42.         #f
  43.         (lambda (sexp grm) (write sexp))
  44.         #f))
  45.  
  46. (defgrammar 'null
  47.   (make-grammar 'null
  48.         (lambda (grm) (math-error "cannot read null grammar"))
  49.         #f
  50.         #f
  51.         (lambda (sexp grm) #t)
  52.         #f))
  53.  
  54. ;;; Establish autoload for PRETTY-PRINT.
  55. (define (pretty-print . args)
  56.   (require 'pretty-print) (apply pretty-print args))
  57. (defgrammar 'SchemePretty
  58.   (make-grammar 'SchemePretty
  59.         (lambda (grm) (read))
  60.         #f
  61.         #f
  62.         (lambda (sexp grm) (pretty-print sexp))
  63.         #f))
  64.  
  65. (define (read-sexp grm)
  66.   (funcall (grammar-reader grm) grm))
  67. (define (write-sexp sexp grm)
  68.   (funcall (grammar-writer grm) sexp grm))
  69.  
  70. (define write-diag write)        ;for now
  71. (define display-diag display)    ;for now
  72. (define newline-diag newline)    ;for now
  73.  
  74. ;;;; careful write for displaying internal stuff
  75. (define (math_print obj)
  76.   (cond ((pair? obj)
  77.      (display-diag #\()
  78.      (math_print (car obj))
  79.      (cond ((null? obj))
  80.            ((pair? (cdr obj))
  81.         (for-each (lambda (x) (display-diag #\ ) (math_print x))
  82.               (cdr obj)))
  83.            (else (display-diag " . ") (math_print (cdr obj))))
  84.      (display-diag #\)))
  85.     ((poly_var? obj) (display-diag (var->sexp obj)))
  86.     (else (write-diag obj)))
  87.   obj)
  88. (define (math:warn . args)
  89.   (display-diag ";;;")
  90.   (let ((ans '()))
  91.     (for-each (lambda (obj)
  92.         (display-diag #\space)
  93.         (if (string? obj)
  94.             (display-diag obj)
  95.             (set! ans (math_print obj))))
  96.           args)
  97.     (newline-diag)
  98.     ans))
  99. (define (math-error . args)
  100.   (newline-diag)
  101.   (apply math:warn args)
  102.   (if math_debug (error "") (math_exit #f)))
  103. (define eval-error math-error)
  104. (define (math-assert test . args)
  105.   (if (not test) (apply math-error args)))
  106. (define (test ans fun . args)
  107.   (let ((res (apply fun args)))
  108.     (if (equal? ans res) #t (math:warn "trouble with " fun))))
  109.  
  110. ;;; outputs list of strings with as much per line as possible.
  111. (define (block-write-strings l)
  112.   (let* ((column 5)
  113.      (width (- (output-port-width (current-output-port)) column))
  114.      (ps (make-string column #\  )))
  115.     (set! column width)
  116.     (for-each (lambda (ap)
  117.         (set! column (+ (string-length ap) column))
  118.         (cond ((>= column width)
  119.                (newline)
  120.                (display ps)
  121.                (set! column (string-length ap)))
  122.               (else
  123.                (display " ")
  124.                (set! column (+ column 1))))
  125.         (display ap))
  126.           l)
  127.     (newline)))
  128.